home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0164_enhanced cross-fade.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  2KB  |  77 lines
  1. {
  2. David Proper posted a cross-fade routine here, some days ago. This is an update
  3. on that one. It now fades all texts. Quite a pain to figure this out, realy.
  4. Put it in the SWAG if you want, Gayle/Kerry/Jeff.
  5. >--- cut here }
  6.  
  7. program xfade;
  8. { made by Bas van Gaalen, Holland, PD,
  9.   fido 2:285/213.8, internet bas.van.gaalen@schotman.nl }
  10. uses crt;
  11. const
  12.   vseg=$a000; fseg=$f000; fofs=$fa6e; lines=13;
  13.   creds:array[0..lines-1] of string[20]=(
  14.     {.........|.........|}
  15.     'This cross-fade',
  16.     'routine was made by',
  17.     'Bas van Gaalen',
  18.     'Code and idea',
  19.     'inspired by',
  20.     'David Proper',
  21.     'This routine was',
  22.     'enhanced a bit',
  23.     'in comparison with',
  24.     'David''s one...',
  25.     'cu later',
  26.     'alligator!',
  27.     '');
  28.  
  29. procedure setpal(c,r,g,b:byte); assembler; asm
  30.   mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]
  31.   out dx,al; mov al,[g]; out dx,al; mov al,[b]; out dx,al; end;
  32.  
  33. procedure retrace; assembler; asm
  34.   mov dx,3dah; @vert1: in al,dx; test al,8; jz @vert1
  35.   @vert2: in al,dx; test al,8; jnz @vert2; end;
  36.  
  37. procedure cleartxt(col,new:byte);
  38. var x,y,vofs:word;
  39. begin
  40.   for x:=0 to 319 do for y:=100 to 107 do begin
  41.     vofs:=y*320+x;
  42.     if mem[vseg:vofs]=col then mem[vseg:vofs]:=0
  43.     else if mem[vseg:vofs]<>0 then mem[vseg:vofs]:=new;
  44.   end;
  45. end;
  46.  
  47. procedure writetxt(col,cur:byte; txt:string);
  48. var x,y,vofs:word; i,j,k:byte;
  49. begin
  50.   x:=(320-8*length(txt)) div 2; y:=100;
  51.   for i:=1 to length(txt) do for j:=0 to 7 do for k:=0 to 7 do
  52.     if ((mem[fseg:fofs+ord(txt[i])*8+j] shl k) and 128) <> 0 then begin
  53.       vofs:=(y+j)*320+(i*8)+x+k;
  54.       if mem[vseg:vofs]=cur then mem[vseg:vofs]:=col+cur else
  55. mem[vseg:vofs]:=col;    end;
  56. end;
  57.  
  58. var txtidx,curcol,i:byte;
  59. begin
  60.   asm mov ax,13h; int 10h; end;
  61.   setpal(1,0,0,0); setpal(2,0,0,0); setpal(3,63 div 2,63,63 div 2);
  62.   curcol:=1; txtidx:=0;
  63.   repeat
  64.     cleartxt(curcol,3-curcol);
  65.     writetxt(curcol,3-curcol,creds[txtidx]);
  66.     for i:=0 to 63 do begin
  67.       retrace;
  68.       setpal(curcol,i div 2,i,i div 2);
  69.       setpal(3-curcol,(63-i) div 2,63-i,(63-i) div 2);
  70.     end;
  71.     delay(500);
  72.     curcol:=1+(curcol mod 2);
  73.     txtidx:=(1+txtidx) mod lines;
  74.   until keypressed;
  75.   textmode(lastmode);
  76. end.
  77.